Shareware Grab Bag/Shareware Grab Bag.iso/001/pibcalc.arc/DOGUYS.PAS

Pascal/Delphi Source File | 1985-03-08 | 26.6 KB | 712 lines

(*--------------------------------------------------------------------------*)
(*                 DoExit --- Set flags to terminate PibCalc                *)
(*--------------------------------------------------------------------------*)

PROCEDURE DoExit;

(*--------------------------------------------------------------------------*)
(*                                                                          *)
(*     Procedure:  DoExit                                                   *)
(*                                                                          *)
(*     Purpose:    Sets flags to terminate PibCalc                          *)
(*                                                                          *)
(*     Calling sequence:                                                    *)
(*                                                                          *)
(*        DoExit;                                                           *)
(*                                                                          *)
(*     Calls:                                                               *)
(*                                                                          *)
(*        CheckEol;                                                         *)
(*                                                                          *)
(*     Remarks:    Done is set TRUE here.                                   *)
(*                                                                          *)
(*--------------------------------------------------------------------------*)

BEGIN   (* DoExit *)

   CheckEol;
                                   (* Set global flag to terminate run *)
   done := TRUE;

END     (* DoExit *);

(*--------------------------------------------------------------------------*)
(*                 DoHelp --- Display online help                           *)
(*--------------------------------------------------------------------------*)

PROCEDURE DoHelp;

(*--------------------------------------------------------------------------*)
(*                                                                          *)
(*     Procedure:  DoHelp                                                   *)
(*                                                                          *)
(*     Purpose:    Display online help                                      *)
(*                                                                          *)
(*     Calling sequence:                                                    *)
(*                                                                          *)
(*        DoHelp;                                                           *)
(*                                                                          *)
(*     Calls:                                                               *)
(*                                                                          *)
(*        CheckEol;                                                         *)
(*                                                                          *)
(*     Remarks:                                                             *)
(*                                                                          *)
(*        The file PIBCALC.HLP must be accessible in order for the help     *)
(*        to be displayed.                                                  *)
(*                                                                          *)
(*--------------------------------------------------------------------------*)

LABEL
   1, 2;

VAR
   nlines:   INTEGER;
   x:        CHAR;
   astflag:  BOOLEAN;
   astcount: INTEGER;
   HelpText: AnyStr;
   I:        INTEGER;
   L:        INTEGER;

BEGIN (* DoHelp *)

                                   (* Get help file *)

   ASSIGN( HelpFile, 'PIBCALC.HLP' );
      (*$I-*)
   RESET ( HelpFile );
      (*$I+*

                                   (* If can't be opened, skip help *)

   IF IoResult <> 0 THEN
      BEGIN
         Writeln('File PIBHELP.HLP cannot be accessed, no HELP available.');
         GOTO 1;
      END;
                                   (* lines per screen-full *)
   nlines := 23;
                                   (* loop over lines in file *)
   REPEAT
                                   (* Screen full -- prompt for next action *)
                                   (* <CR> continues, S stops listing,      *)
                                   (* C continues non-stop, ? get options.  *)

      IF nlines = 0 THEN
         BEGIN  (* NLINES = 0 *)

            2: TEXTCOLOR( Prompt_Color );
               WRITE('S/C/?/RETURN: ');
               TEXTCOLOR( ForeGround_Color );

               x := ' ';
               READLN(x);
               WRITELN;

               CASE x OF
                  'S','s' : GOTO 1;
                  'C','c' : nlines := MAXINT;
                  ' ',cr  : nlines := 23;
                  ELSE
                     BEGIN  (* DISPLAY INSTRUCTIONS *)
                        WRITELN;
                        TEXTCOLOR( Prompt_Color );
                        WRITELN('Your options are:');
                        WRITELN;
                        WRITELN('S - Stop the listing.');
                        WRITELN('C - Continue with no more prompting.');
                        WRITELN('? - Display these instructions.');
                        WRITELN('Just carriage return - ',
                                'display next page.');
                        WRITELN;
                        TEXTCOLOR( ForeGround_Color );
                        GOTO 2;
                     END (* DISPLAY INSTRUCTIONS *);

                  END (* CASE *);

         END (* NLINES = 0 *);

      astflag  := TRUE;
      astcount := 0;
                                   (* Read next line from help file *)

      READLN( HelpFile , HelpText );

      L := LENGTH( HelpText );

                                   (* Check initial '*' flagging *)

      I := 1;

      WHILE astflag DO
         BEGIN

            IF I <= L THEN
               IF HelpText[I] = '*' THEN
                  BEGIN
                     HelpText[I] := ' ';
                     astcount    := astcount + 1;
                  END
               ELSE
                  astflag := FALSE
            ELSE
               astflag := FALSE;

            I := I + 1;

         END;
                                   (* Select display color *)
      IF astcount = 3 THEN
         TEXTCOLOR( Help_Header_Color )
      ELSE
         TEXTCOLOR( Help_Text_Color );

                                   (* Display line of help *)
      WRITELN( HelpText );
                                   (* Decrement screen disploay count *)
      nlines := nlines - 1;

   UNTIL (  EOF( HelpFile ) );

   CLOSE( HelpFile );

   TEXTCOLOR( Help_Text_Color );

   WRITELN;
   WRITELN('For a printed listing of this help file type the DOS command');
   WRITELN('PRINT PIBCALC.HLP');
   WRITELN;

   TEXTCOLOR( Foreground_Color );

1:
END  (* DoHelp *);


(*--------------------------------------------------------------------------*)
(*                 DoShow --- Display variables and functions               *)
(*--------------------------------------------------------------------------*)

PROCEDURE DoShow;

(*--------------------------------------------------------------------------*)
(*                                                                          *)
(*     Procedure:  DoShow                                                   *)
(*                                                                          *)
(*     Purpose:    Displays variables and functions                         *)
(*                                                                          *)
(*     Calling sequence:                                                    *)
(*                                                                          *)
(*        DoShow;                                                           *)
(*                                                                          *)
(*     Calls:                                                               *)
(*                                                                          *)
(*        CheckEol;                                                         *)
(*                                                                          *)
(*--------------------------------------------------------------------------*)

VAR
   t: tokenty;
   v: varnamty;
   i: INTEGER;
   j: INTEGER;

BEGIN  (* DoShow *)

                                   (* Get next token  -- *)
   NextTok;
                                   (* indicates if vars or funcs to be *)
                                   (* displayed                        *)
   t := token;
                                   (* Check for garbage at EOL         *)
   CheckEol;

   CASE t OF
                                   (* Display variables *)

      varssy:  FOR v := 'A' TO 'Z' DO
                  IF VarVals[v].def THEN Display( v , VarVals[v] );

                                   (* Display functions *)

      funcssy: FOR i := 1 TO Maxuserfuncs DO

                  WITH userfuncs[i] DO
                     IF name <> '          ' THEN
                        BEGIN

                           j := 1;

                                   (* Write function name *)

                           WHILE ( name[j] <> ' ' ) AND ( j <= 10 ) DO
                              BEGIN
                                 WRITE( name[j] );
                                 j := j + 1;
                              END;

                                   (* Write argument names if any *)

                           IF nparms > 0 THEN
                              BEGIN

                                 WRITE('(');

                                 FOR j := 1 TO ( nparms - 1 ) DO
                                    WRITE(pnames[j],',');

                                 WRITE(pnames[nparms],')')

                              END;

                           WRITE('=');

                           j := 1;
                                   (* Write function definition *)

                           WHILE defn[j] <> col DO
                              BEGIN
                                 WRITE(defn[j]);
                                 j := j + 1;
                              END;

                           WRITELN;

                     END;
      ELSE
         SynErr;
      END;

END   (* DoShow *);


(*--------------------------------------------------------------------------*)
(*                 DoEsp --- Execute subordinate program                    *)
(*--------------------------------------------------------------------------*)

PROCEDURE DoEsp;

(*--------------------------------------------------------------------------*)
(*                                                                          *)
(*     Procedure:  DoEsp                                                    *)
(*                                                                          *)
(*     Purpose:    Executes subordinate program                             *)
(*                                                                          *)
(*     Calling sequence:                                                    *)
(*                                                                          *)
(*        DoEsp;                                                            *)
(*                                                                          *)
(*     Calls:                                                               *)
(*                                                                          *)
(*     Remarks:    Not yet implemented.                                     *)
(*                                                                          *)
(*--------------------------------------------------------------------------*)

BEGIN  (* DoEsp *)

   WRITELN('The $ command is not implemented for MS/DOS');

END    (* DoEsp *);

(*--------------------------------------------------------------------------*)
(*                 DoDef --- Add user function definition                   *)
(*--------------------------------------------------------------------------*)

PROCEDURE DoDef;

(*--------------------------------------------------------------------------*)
(*                                                                          *)
(*     Procedure:  DoDef                                                    *)
(*                                                                          *)
(*     Purpose:    Add user function definition                             *)
(*                                                                          *)
(*     Calling sequence:                                                    *)
(*                                                                          *)
(*        DoDef;                                                            *)
(*                                                                          *)
(*     Calls:                                                               *)
(*                                                                          *)
(*        NextTok                                                           *)
(*        SynErr                                                            *)
(*        CheckEol                                                          *)
(*                                                                          *)
(*--------------------------------------------------------------------------*)

LABEL
   99 (* ERROR EXIT *);

VAR
   i:     INTEGER;
   fname: alfa;
   found: BOOLEAN;
   slot:  INTEGER;

BEGIN (* Dodef *)
                                   (* Skip blanks *)

   WHILE Iline[ipos] = ' ' DO Ipos := Ipos+1;

                                   (* 1st char of function name must be *)
                                   (* letter                            *)

   IF NOT (Iline[ipos] IN ['A'..'Z']) THEN
      BEGIN
         SynErr;
         GOTO 99;
      END;

   i := 0;
                                   (* Pick up function name *)

   WHILE (Iline[ipos] IN ['A'..'Z','0'..'9']) AND (i < 9) DO
      BEGIN
         i        := i + 1;
         fname[i] := Iline[ipos];
         Ipos     := Ipos + 1;
      END;
                                   (* Blank fill function name *)

   FOR i := ( i + 1 ) TO 10 DO fname[i] := ' ';

   found := FALSE;
   i     := 0;
                                   (* Check if function name conflicts *)
                                   (* with reserved word               *)

   WHILE ( i < Maxtoknams ) AND ( NOT found ) DO
      BEGIN
         i     := i + 1;
         found := ( fname = toknams[i].name );
      END;

   IF found THEN
      BEGIN
         Error('Function name conflicts with reserved word');
         GOTO 99;
      END;

                                   (* Find slot for function name *)

   slot := 0;
                                   (* First see if this is redefinition. *)
                                   (* If so, reuse current slot.         *)

   WHILE ( slot < Maxuserfuncs ) AND ( NOT found ) DO
      BEGIN
         slot  := slot + 1;
         found := ( fname = userfuncs[slot].name );
      END;

                                   (* Not redefinition -- look for *)
                                   (* empty slot (name is blank)   *)
   IF NOT found THEN
      BEGIN

         slot := 0;

         WHILE ( slot < Maxuserfuncs ) AND ( NOT found ) DO
            BEGIN
               slot  := slot + 1;
               found := ( userfuncs[slot].name = '          ' );
            END;

                                   (* No slot found -- error *)

         IF NOT found THEN
            BEGIN
               Error ('No more room for user functions');
               GOTO 99;
            END;

      END;

   IF ErrorFlag THEN GOTO 99;

                                   (* Get definition *)
   WITH userfuncs[slot] DO
      BEGIN
                                   (* Insert function name *)
         name   := fname;
         nparms := 0;
                                   (* Look for '(', signalling start *)
                                   (* of parameter list              *)
         NextTok;

         IF token = oparsy THEN
            BEGIN

               NextTok;
                                   (* Ensure parameter is variable name *)

               IF token <> varsy THEN
                  BEGIN
                     SynErr;
                     GOTO 99;
                  END;

               nparms    := 1;
               pnames[1] := varnam;

                                    (* Pick up any remaining parameters *)
               NextTok;

               WHILE ( token = commasy ) AND ( nparms < Maxformal ) DO
                  BEGIN

                     NextTok;
                                   (* Check next parameter is variable name *)

                     IF token <> varsy THEN
                        BEGIN
                           SynErr;
                           GOTO 99;
                        END;

                                   (* Check for duplicate parameter names *)

                     FOR i := 1 TO nparms DO
                        IF varnam = pnames[i] THEN
                           BEGIN
                              SynErr;
                              GOTO 99;
                           END;

                                   (* Insert parameter name *)

                     nparms         := nparms + 1;
                     pnames[nparms] := varnam;

                                   (* Get next separator *)
                     NextTok;

                  END;
                                   (* ')' should follow last formal *)
                                   (* parameter                     *)

               IF token <> cparsy THEN
                  BEGIN
                     SynErr;
                     GOTO 99;
                  END;

               NextTok;

            END;

            IF ErrorFlag THEN GOTO 99;

                                   (* Now pick up function definition *)
                                   (* '=' should follow ')' closing   *)
                                   (* formal paramater list           *)

            IF token <> equalssy THEN
               BEGIN
                  SynErr;
                  GOTO 99;
               END;


            i := 0;
                                   (* Get text of definition *)

            WHILE Iline[ipos] <> col DO
               BEGIN
                  i       := i + 1;
                  defn[i] := Iline[ipos];
                  Ipos    := Ipos + 1;
               END;

            defn[i+1] := COL;

      END;

99 : END (* Dodef *);

(*--------------------------------------------------------------------------*)
(*                 DoDel --- Remove user function definition                *)
(*--------------------------------------------------------------------------*)

PROCEDURE DoDel;

(*--------------------------------------------------------------------------*)
(*                                                                          *)
(*     Procedure:  DoDel                                                    *)
(*                                                                          *)
(*     Purpose:    Removes user function definition                         *)
(*                                                                          *)
(*     Calling sequence:                                                    *)
(*                                                                          *)
(*        DoDel;                                                            *)
(*                                                                          *)
(*     Calls:                                                               *)
(*                                                                          *)
(*        NextTok                                                           *)
(*        SynErr                                                            *)
(*        CheckEol                                                          *)
(*                                                                          *)
(*--------------------------------------------------------------------------*)

VAR
   t: tokenty;

BEGIN  (* DoDel *)

                                   (* Pick up name of function *)
   NextTok;
                                   (* If not var name/function name, error *)

   IF NOT (token IN [varsy,userfuncsy]) THEN SynErr;

                                   (* Ensure no trailing garbage *)
   IF ( NOT ErrorFlag ) THEN
      BEGIN

         t := token;

         CheckEol;
                                   (* If variable, indicate undefined, *)
                                   (* if function, remove definition   *)

         IF ( NOT ErrorFlag ) THEN
            IF t = varsy THEN
               VarVals[varnam].def := FALSE
            ELSE
               userfuncs[iuserfunc].name := '          ';

     END;

END  (* DoDel *);

(*--------------------------------------------------------------------------*)
(*                 DoExp --- Evaluate expression in command                 *)
(*--------------------------------------------------------------------------*)

PROCEDURE DoExp;

(*--------------------------------------------------------------------------*)
(*                                                                          *)
(*     Procedure:  DoExp                                                    *)
(*                                                                          *)
(*     Purpose:    Evaluates expression in command line                     *)
(*                                                                          *)
(*     Calling sequence:                                                    *)
(*                                                                          *)
(*        DoExp;                                                            *)
(*                                                                          *)
(*     Calls:                                                               *)
(*                                                                          *)
(*        NextTok                                                           *)
(*        Expression                                                        *)
(*                                                                          *)
(*--------------------------------------------------------------------------*)

LABEL
   99 (* ERROR EXIT *);

VAR
   setvar:   BOOLEAN;
   vartoset: varnamty;
   v:        valuety;

BEGIN (* DoExp *)

                                   (* Assume non-assignment expression *)
   setvar := FALSE;
                                   (* See if '=' follows token -- is an *)
                                   (* assignment statement.             *)
   IF token = varsy THEN
   BEGIN
      NextTok;
      IF token = equalssy THEN
         BEGIN
            setvar   := TRUE;
            vartoset := varnam;
            NextTok;
         END
      ELSE
         BEGIN
            Ipos := 1;
            NextTok;
         END
   END;

                                   (* Parse and execute expression *)

   Expression( dummy, Iline, Ipos, v );

                                   (* Quit if error *)
   IF ErrorFlag THEN GOTO 99;
                                   (* Garbage after expression ? *)
   IF token <> eolsy THEN
      BEGIN
         SynErr;
         GOTO 99;
      END;
                                   (* No errors -- display result *)
   IF ( NOT ErrorFlag ) THEN
      BEGIN
         curval := v;
         IF setvar THEN VarVals[vartoset] := v;
         Display(' ',v);
      END;

99:

END (* DoExp *);


(*--------------------------------------------------------------------------*)
(*                 DoEdit --- Edit last command line                        *)
(*--------------------------------------------------------------------------*)

PROCEDURE DoEdit;

(*--------------------------------------------------------------------------*)
(*                                                                          *)
(*     Procedure:  DoEdit                                                   *)
(*                                                                          *)
(*     Purpose:    Edits last command line.                                 *)
(*                                                                          *)
(*     Calling sequence:                                                    *)
(*                                                                          *)
(*        DoEdit;                                                           *)
(*                                                                          *)
(*        On output, UseEdit = TRUE and Oline contains the edited command.  *)
(*                                                                          *)
(*     Calls:                                                               *)
(*                                                                          *)
(*        TextColor                                                         *)
(*        COPY                                                              *)
(*        Edit_String                                                       *)
(*                                                                          *)
(*--------------------------------------------------------------------------*)

VAR
   c:       CHAR;
   i:       INTEGER;

BEGIN (* DoEdit *)

                                   (* Prompt for editing line *)
   TEXTCOLOR(Prompt_Color);
   WRITE('>> ');
   TEXTCOLOR(ForeGround_Color);
                                   (* Indicate we will use edited line *)
   UseEdit := TRUE;
                                   (* Strip EOL marker from command *)

   Oline   := COPY( Oline, 1, LENGTH( Oline ) - 1 );

                                   (* Edit the command *)

   c       := Edit_String( Oline, MaxStrLen, 4, WhereY, TRUE );

                                   (* Append EOL marker  *)
   Oline := Oline + Col;
                                   (* Prevent overwrites *)
   WRITELN;

END   (* DoEdit *);